home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / skk / skk-attr.el.z / skk-attr.el
Encoding:
Text File  |  1998-05-21  |  17.4 KB  |  410 lines
  1. ;; -*-byte-compile-dynamic: t;-*-
  2. ;;; skk-attr.el --- SKK $BC18lB0@-%a%s%F%J%s%9%W%m%0%i%`(B
  3. ;; Copyright (C) 1997 Mikio Nakajima <minakaji@osaka.email.ne.jp>
  4.  
  5. ;; Author: Mikio Nakajima <minakaji@osaka.email.ne.jp>
  6. ;; Maintainer: Mikio Nakajima <minakaji@osaka.email.ne.jp>
  7. ;; Version: $Id: skk-attr.el,v 1.3 1997/10/25 11:03:15 mrt Exp $
  8. ;; Keywords: japanese
  9. ;; Last Modified: $Date: 1997/10/25 11:03:15 $
  10.  
  11. ;; This program is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either versions 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with SKK, see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
  24. ;; MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; Following people contributed modifications to skk.el (Alphabetical order):
  29.  
  30. ;;; Change log:
  31.  
  32. ;;; Code:
  33. (eval-when-compile (require 'skk))
  34.  
  35. ;;;###skk-autoload
  36. (defvar skk-attr-file (if (eq system-type 'ms-dos) "~/_skk-attr" "~/.skk-attr")
  37.   "*SKK $B$NC18l$NB0@-$rJ]B8$9$k%U%!%$%k!#(B")
  38.  
  39. ;;;###skk-autoload
  40. (defvar skk-attr-backup-file
  41.   (if (eq system-type 'ms-dos) "~/_skk-attr.BAK" "~/.skk-attr.BAK" )
  42.   "*SKK $B$NC18l$NB0@-$rJ]B8$9$k%U%!%$%k!#(B")
  43.  
  44. ;;;###skk-autoload
  45. (defvar skk-attr-search-function nil
  46.   "*skk-search-jisyo-file $B$,8uJd$r8+$D$1$?$H$-$K%3!<%k$5$l$k4X?t!#(B
  47. $B8+=P$78l!"Aw$j2>L>!"%(%s%H%j!<$N(B 3 $B0z?t$rH<$J$C$F!"(B
  48. skk-attr-default-update-function $B$,%3!<%k$5$l$?8e$K%3!<%k$5$l$k!#(B" )
  49.  
  50. ;;;###skk-autoload
  51. (defvar skk-attr-default-update-function
  52.   (function (lambda (midasi okurigana word purge)
  53.               (or skk-attr-alist (skk-attr-read))
  54.               (if purge
  55.                   (skk-attr-purge midasi okurigana word)
  56.                 ;; time $BB0@-$K(B current-time $B$NJV$jCM$rJ]B8$9$k!#(B                
  57.                 (skk-attr-put midasi okurigana word 'time (current-time)) )))
  58.   "*skk-search-jisyo-file $B$,8uJd$r8+$D$1$?$H$-$K%3!<%k$5$l$k4X?t!#(B
  59. $B8+=P$78l!"Aw$j2>L>!"%(%s%H%j!<$N(B 3 $B0z?t$rH<$J$C$F!"(B
  60. skk-attr-default-update-function $B$,%3!<%k$5$l$kA0$K%3!<%k$5$l$k!#(B" )
  61.  
  62. ;;;###skk-autoload
  63. (defvar skk-attr-update-function nil
  64.   "*skk-update-jisyo $B$NCf$G%3!<%k$5$l$k4X?t!#(B
  65. $B8+=P$78l!"Aw$j2>L>!"%(%s%H%j!<!"%Q!<%8$N(B 4 $B0z?t$rH<$J$C$F%3!<%k$5$l$k!#(B" )
  66.  
  67. ;;;###skk-autoload
  68. (defvar skk-attr-alist nil
  69.   "SKK $BB0@-$rE83+$9$k%(!<%j%9%H!#(B" )
  70.  
  71. ;; data structure
  72. ;; $B$H$j$"$($:!"3FJQ49Kh$KB0@-$N99?7$r9T$J$$0W$$$h$&$K!"8+=P$78l$+$i3FB0@-$r0z(B
  73. ;; $B=P$70W$$$h$&$K$9$k!#$3$&$d$C$F$7$^$&$H!"$"$kB0@-$r;}$DC18l$rH4$-=P$9$N$,LL(B
  74. ;; $BE]$K$J$k$,!";_$`$rF@$J$$$+(B...$B!#(B
  75. ;;
  76. ;; $B9bB.2=$N$?$a$K(B 2 $B$D$N%O%C%7%e%-!<$r;}$D$h$&$K$9$k!#(B1 $B$D$O(B okuri-ari $B$+(B
  77. ;; okuri-nasi $B$+!#(B2 $B$D$a$O8+=P$78l$N@hF,$NJ8;z!#(B
  78. ;;
  79. ;; '((okuri-ari . (("$B$"(B" . ("$B$"(Bt" .
  80. ;;                          ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B"))
  81. ;;                                  (time . (13321 10887 982100))
  82. ;;                                  (anything . ...) )
  83. ;;                          ("$B9g(B" . (okurigana . ("$B$C$F(B" "$B$C$?(B"))
  84. ;;                                  (time . (13321 10953 982323)
  85. ;;                                  (anything . ...) )
  86. ;;                          ("$B2q(B" . (okurigana . ("$B$C$F(B"))
  87. ;;                                  (time . (13321 10977 312335))
  88. ;;                                  (anything . ...) ))
  89. ;;                         ("$B$"$D$+(Bw" . ...) )
  90. ;;                 ("$B$$(B" . ...) )
  91. ;;   (okuri-nasi . (("$B$"(B" . ...) ("$B$$(B" . ...))) )
  92. ;; 
  93. ;; $B$7$+$7!"$3$&$$$&$b$N$r:n$k$H!"(B.skk-jisyo $B$H(B .skk-attr $B$NN>J}$r;}$D0UL#$,Gv(B
  94. ;; $B$l$F$7$^$&$s$@$h$M(B...$B!#>e<j$/F0$1$P(B .skk-attr $B$KE}9g$7$F$bNI$$$1$I!"<-=q$N(B
  95. ;; $B%a%s%F%J%s%9$,LLE]$K$J$k$+(B...$B!#(B
  96.  
  97. (defsubst skk-attr-get-table (okuri-ari)
  98.   (assq (if okuri-ari 'okuri-ari 'okuri-nasi) skk-attr-alist) )
  99.  
  100. (defsubst skk-attr-get-table-for-midasi (midasi okurigana)
  101.   ;; get all entries for MIDASI.
  102.   ;; e.g.
  103.   ;;  ("$B$"(Bt" . ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B"))
  104.   ;;                   (time . (13321 10887 982100))
  105.   ;;                   (anything . ...) )
  106.   ;;           ("$B9g(B" . (okurigana . ("$B$C$F(B" "$B$C$?(B"))
  107.   ;;                   (time . (13321 10953 982323)
  108.   ;;                   (anything . ...) )
  109.   ;;           ("$B2q(B" . (okurigana . ("$B$C$F(B"))
  110.   ;;                   (time . (13321 10977 312335))
  111.   ;;                   (anything . ...) ))
  112.   (assoc midasi (cdr (assoc (skk-substring-head-character midasi)
  113.                             (cdr (skk-attr-get-table okurigana)) ))))
  114.  
  115. (defsubst skk-attr-get-table-for-word (midasi okurigana word)
  116.   ;; get a table for WORD.
  117.   ;; e.g.
  118.   ;;  ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B")) (time . (13321 10887 982100))
  119.   ;;          (anything . ...) )
  120.   (assoc word (cdr (skk-attr-get-table-for-midasi midasi okurigana))) )
  121.  
  122. (defsubst skk-attr-get-all-attrs (midasi okurigana word)
  123.   ;; get all attributes for MIDASI and WORD.
  124.   ;; e.g.
  125.   ;; ((okurigana . "$B$?(B" "$B$F(B") (time . (13321 10887 982100)) (anything . ...))
  126.   (cdr (skk-attr-get-table-for-word midasi okurigana word)) )
  127.  
  128. (defsubst skk-attr-get (midasi okurigana word name)
  129.   (assq name (skk-attr-get-all-attrs midasi okurigana word)) )
  130.   
  131. (defun skk-attr-put (midasi okurigana word name attr)
  132.   ;; add attribute ATTR for MIDASI, WORD and NAME.
  133.   ;; e.g.
  134.   ;; table := ("$B$"(Bt" . ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B"))
  135.   ;;                           (time . (13321 10887 982100))
  136.   ;;                           (anything . ...) )
  137.   ;;                   ("$B9g(B" . (okurigana . (("$B$C$F(B" "$B$C$?(B"))
  138.   ;;                           (time . (13321 10953 982323))
  139.   ;;                           (anything . ...) )
  140.   ;;                   ("$B2q(B" . (okurigana . ("$B$C$F(B"))
  141.   ;;                           (time . (13321 10977 312335))
  142.   ;;                           (anything . ...) ))
  143.   ;; entry := ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B")) (time . (13321 10887 982100))
  144.   ;;                  (anything . ...) )
  145.   ;; oldattr := (time . (13321 10887 982100))
  146.   ;;
  147.   (let* ((table (skk-attr-get-table-for-midasi midasi okurigana))
  148.          (entry (assoc word (cdr table)))
  149.          (oldattr (assq name (cdr entry))) )
  150.     (cond (oldattr
  151.            (cond ((eq name 'okurigana) ; anything else?
  152.                   (setcdr oldattr (cons attr (delete attr (nth 1 oldattr)))) )
  153.                  (t (setcdr oldattr attr)) ))
  154.           (entry (setcdr entry (cons (cons name attr) (cdr entry))))
  155.           ;; new entry
  156.           (t (skk-attr-put-1 midasi okurigana word name attr) ))))
  157.  
  158. (defun skk-attr-put-1 (midasi okurigana word name attr)
  159.   ;; header := "$B$"(B"
  160.   ;; table := ((okuri-ari . (("$B$"(B" . ("$B$"(Bt" .
  161.   ;;                            ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B"))
  162.   ;;                                    (time . (13321 10887 982100))
  163.   ;;                                    (anything . ...) )
  164.   ;;                            ("$B9g(B" . (okurigana . ("$B$C$F(B" "$B$C$?(B"))
  165.   ;;                                    (time . (13321 10953 982323))
  166.   ;;                                    (anything . ...) )
  167.   ;;                            ("$B2q(B" . (okurigana . ("$B$C$F(B"))
  168.   ;;                                    (time . (13321 10977 312335))
  169.   ;;                                    (anything . ...) )))
  170.   ;; table2 := ("$B$"(B" . ("$B$"(Bt" .
  171.   ;;                            ("$BEv(B" . (okurigana . ("$B$?(B" "$B$F(B"))
  172.   ;;                                    (time . (13321 10887 982100))
  173.   ;;                                    (anything . ...) )
  174.   ;;                            ("$B9g(B" . (okurigana . ("$B$C$F(B" "$B$C$?(B"))
  175.   ;;                                    (time . (13321 10953 982323)
  176.   ;;                                    (anything . ...) )
  177.   ;;                            ("$B2q(B" . (okurigana . ("$B$C$F(B"))
  178.   ;;                                    (time . (13321 10977 312335))
  179.   ;;                                    (anything . ...) )))
  180.   (let* ((table (skk-attr-get-table okurigana))
  181.          (header (skk-substring-head-character midasi))
  182.          (table2 (assoc header (cdr table)))
  183.          (add (cons midasi (list
  184.                             (cons word
  185.                                   (if okurigana
  186.                                       ;; default attribute for okuri-ari
  187.                                       (list (cons 'okurigana (list okurigana))
  188.                                             ;; default attribute
  189.                                             ;;(cons 'midasi midasi)
  190.                                             ;; and new one
  191.                                             (cons name attr) )
  192.                                     (list
  193.                                      ;; default attribute
  194.                                      ;;(cons 'midasi midasi)
  195.                                      ;; and new one
  196.                                      (cons name attr) )))))))
  197.     (cond (table2
  198.            ;; header $B$"$j(B
  199.            (setcdr table2 (cons add (cdr table2))) )
  200.           ;; header $B$J$7(B
  201.           ((cdr table)
  202.            (setcdr table (cons (cons header (list add)) (cdr table))) )
  203.           (t (setcdr table (list (cons header (list add))))) )))
  204.  
  205. (defun skk-attr-remove (midasi okurigana word name)
  206.   ;; delete attribute ATTR for MIDASI, WORD and NAME.
  207.   ;; e.g.
  208.   ;; attrs := ((okurigana . ("$B$?(B" "$B$F(B")) (time . (13321 10887 982100))
  209.   ;;           (anything . ...) )
  210.   ;; del := (time . (13321 10887 982100))
  211.   ;;
  212.   (let* ((table (skk-attr-get-all-attrs midasi okurigana word))
  213.          (del (assq name table)) )
  214.     (and del (setq table (delq del table))) ))
  215.  
  216. ;;;###skk-autoload
  217. (defun skk-attr-purge (midasi okurigana word)
  218.   ;; purge a whole entry for MIDASI and WORD.
  219.   (let* ((table (cdr (skk-attr-get-table-for-midasi midasi okurigana)))
  220.          (del (assoc word table)) )
  221.     (and del (setq del (delq del table))) ))
  222.     
  223. ;;;###skk-autoload
  224. (defun skk-attr-read (&optional nomsg)
  225.   "skk-attr-file $B$+$iB0@-$rFI$_9~$`!#(B"
  226.   (interactive "P")
  227.   (skk-create-file
  228.    skk-attr-file
  229.    (if (not nomsg)
  230.        (if skk-japanese-message-and-error
  231.            "SKK $B$NB0@-%U%!%$%k$r:n$j$^$7$?(B"
  232.          "I have created an SKK attributes file for you" )))
  233.   (if (or (null skk-attr-alist)
  234.           (skk-yes-or-no-p (format "%s $B$r:FFI$_9~$_$7$^$9$+!)(B" skk-attr-file)
  235.                            (format "Reread %s?" skk-attr-file) ))
  236.       (let (;;(coding-system-for-read 'euc-japan)
  237.             enable-character-unification )
  238.         (save-excursion
  239.           (unwind-protect
  240.               (progn
  241.                 (set-buffer (get-buffer-create " *SKK attr*"))
  242.                 (erase-buffer)
  243.                 (if (= (nth 1 (insert-file-contents skk-attr-file)) 0)
  244.                     ;; bare alist
  245.                     (insert "((okuri-ari) (okuri-nasi))") )
  246.                 (goto-char (point-min))
  247.                 (or nomsg
  248.                     (skk-message "%s $B$N(B SKK $BB0@-$rE83+$7$F$$$^$9(B..."
  249.                                  "Expanding attributes of %s ..."
  250.                                  (file-name-nondirectory skk-attr-file) ))
  251.                 (setq skk-attr-alist (read (current-buffer)))
  252.                 (or nomsg
  253.                     (skk-message
  254.                      "%s $B$N(B SKK $BB0@-$rE83+$7$F$$$^$9(B...$B40N;!*(B"
  255.                      "Expanding attributes of %s ...done"
  256.                      (file-name-nondirectory skk-attr-file) )))
  257.         (message "%S" (current-buffer))
  258.         ;; Why?  Without this line, Emacs 20 deletes the
  259.         ;; buffer other than skk-attr's buffer.
  260.             (kill-buffer (current-buffer)) ))
  261.         skk-attr-alist )))
  262.  
  263. ;;;###skk-autoload
  264. (defun skk-attr-save (&optional nomsg)
  265.   "skk-attr-file $B$KB0@-$rJ]B8$9$k(B."
  266.   (interactive "P")
  267.   (if (and (null skk-attr-alist) (not nomsg))
  268.       (progn
  269.         (skk-message "SKK $BB0@-$r%;!<%V$9$kI,MW$O$"$j$^$;$s(B"
  270.                      "No SKK attributes need saving" )
  271.         (sit-for 1) )
  272.     (save-excursion
  273.       (if (not nomsg)
  274.           (skk-message "%s $B$K(B SKK $BB0@-$r%;!<%V$7$F$$$^$9(B..."
  275.                        "Saving SKK attributes to %s..." skk-attr-file ))
  276.       (and skk-attr-backup-file
  277.            (copy-file skk-attr-file skk-attr-backup-file
  278.                       'ok-if-already-exists 'keep-date ))
  279.       (set-buffer (find-file-noselect skk-attr-file))
  280.       (if skk-mule3
  281.           (progn
  282.             (if (not (coding-system-p 'iso-2022-7bit-short))
  283.                 (make-coding-system
  284.                  'iso-2022-7bit-short
  285.                  2 ?J
  286.                  "Like `iso-2022-7bit' but no ASCII designation before SPC."
  287.                  '(ascii nil nil nil t t nil t) ))
  288.             (set-buffer-file-coding-system 'iso-2022-7bit-short) ))
  289.       (delete-region 1 (point-max))
  290.       ;; This makes slow down when we have a long attributes alist, but good
  291.       ;; for debugging.
  292.       (if skk-debug (pp skk-attr-alist (current-buffer))
  293.     (prin1 skk-attr-alist (current-buffer)) )
  294.       (write-file skk-attr-file)
  295.       (kill-buffer (current-buffer))
  296.       (if (not nomsg)
  297.           (skk-message "%s $B$K(B SKK $BB0@-$r%;!<%V$7$F$$$^$9(B...$B40N;!*(B"
  298.                        "Saving attributes to %s...done" skk-attr-file )))))
  299.  
  300. ;;(defun skk-attr-mapc (func seq)
  301. ;;  ;; funcall FUNC every element of SEQ.
  302. ;;  (let (e)
  303. ;;    (while (setq e (car seq))
  304. ;;      (setq seq (cdr seq))
  305. ;;      (funcall func e) )))
  306. ;;
  307. ;;(defun skk-attr-get-all-entries (okuri-ari)
  308. ;;  ;; remove hash tables of which key are headchar and midasi, and return all
  309. ;;  ;; entries.
  310. ;;  (let ((table (skk-attr-get-table okuri-ari))
  311. ;;        minitable val entry )
  312. ;;    (while table
  313. ;;      (setq minitable (cdr (car table)))
  314. ;;      (while minitable
  315. ;;        (setq val (cons (car (cdr minitable)) val)
  316. ;;              minitable (cdr minitable) ))
  317. ;;      (setq table (cdr table)) )
  318. ;;    val ))
  319.     
  320. ;;;###skk-autoload
  321. (defun skk-attr-purge-old-entries ()
  322.   "$BD>6a$N(B 30 $BF|4V%"%/%;%9$,$J$+$C$?%(%s%H%j$r8D?M<-=q$+$i%Q!<%8$9$k!#(B"
  323.   (interactive)
  324.   (let ((table (cdr (skk-attr-get-table 'okuri-ari)))
  325.         (oldday (skk-attr-relative-time (current-time) -2592000)) )
  326.     (skk-attr-purge-old-entries-1 table oldday)
  327.     (setq table (cdr (skk-attr-get-table nil)))
  328.     (skk-attr-purge-old-entries-1 table oldday) ))
  329.  
  330. (defun skk-attr-purge-old-entries-1 (table oldday)
  331.   ;; 30 days old
  332.   (let (skk-henkan-okuri-strictly
  333.         skk-henkan-strict-okuri-precedence
  334.         skk-henkan-key
  335.         skk-henkan-okurigana ;; have to bind it to nil
  336.         skk-okuri-char
  337.         skk-search-prog-list ;; not to work skk-public-jisyo-contains-p.
  338.         minitable )
  339.     ;; $B$3$&$$$&$N$r$b$C$H0lHLE*$K=hM}$G$-$k%^%/%m(B ($B4X?t$G$bNI$$$1$I(B) $B$G$b9M$((B
  340.     ;; $B$J$-$c$J$i$s$J(B...
  341.     (while table
  342.       (setq minitable (cdr (car table)))
  343.       (while minitable
  344.         (setq minimini (cdr (car minitable)))
  345.         (while minimini
  346.           (setq e (car minimini))
  347.           (if (skk-attr-time-lessp (cdr (assq 'time (cdr e))) oldday)
  348.               (progn
  349.                 (setq skk-henkan-key (car (car minitable))
  350.                       skk-okuri-char (substring skk-henkan-key -1)
  351.                       ;; $B$3$l$8$c>C$($J$$$_$?$$$M(B...$B!#(B
  352.                       minimini (delq e minimini) )
  353.                 (skk-update-jisyo (car e) 'purge) )
  354.             (setq minimini (cdr minimini)) ))
  355.         (setq minitable (cdr minitable)) )
  356.       (setq table (cdr table)) )))
  357.  
  358. ;; time utilities...
  359. ;;  from ls-lisp.el.  Welcome!
  360. (defun skk-attr-time-lessp (time0 time1)
  361.   (let ((hi0 (car time0))
  362.     (hi1 (car time1))
  363.     (lo0 (nth 1 time0))
  364.     (lo1 (nth 1 time1)) )
  365.     (or (< hi0 hi1) (and (= hi0 hi1) (< lo0 lo1))) ))
  366.  
  367. ;; from timer.el.  Welcome!
  368. (defun skk-attr-relative-time (time secs &optional usecs)
  369.   ;; Advance TIME by SECS seconds and optionally USECS microseconds.
  370.   ;; SECS may be a fraction.
  371.   (let ((high (car time))
  372.     (low (if (consp (cdr time)) (nth 1 time) (cdr time)))
  373.     (micro (if (numberp (car-safe (cdr-safe (cdr time))))
  374.            (nth 2 time)
  375.          0)))
  376.     ;; Add
  377.     (if usecs (setq micro (+ micro usecs)))
  378.     (if (floatp secs)
  379.     (setq micro (+ micro (floor (* 1000000 (- secs (floor secs)))))))
  380.     (setq low (+ low (floor secs)))
  381.  
  382.     ;; Normalize
  383.     (setq low (+ low (/ micro 1000000)))
  384.     (setq micro (mod micro 1000000))
  385.     (setq high (+ high (/ low 65536)))
  386.     (setq low (logand low 65535))
  387.  
  388.     (list high low (and (/= micro 0) micro))))
  389.  
  390. ;; from type-break.el.  Welcome!
  391. (defun skk-attr-time-difference (a b)
  392.   ;; Compute the difference, in seconds, between a and b, two structures
  393.   ;; similar to those returned by `current-time'.
  394.   ;; Use addition rather than logand since that is more robust; the low 16
  395.   ;; bits of the seconds might have been incremented, making it more than 16
  396.   ;; bits wide.
  397.   ;;
  398.   ;; elp.el version...maybe more precisely.
  399.   ;;(+ (* (- (car end) (car start)) 65536.0)
  400.   ;;   (- (nth 1 end) (nth 1 start))
  401.   ;;   (/ (- (nth 2 end) (nth 2 start)) 1000000.0) )
  402.   ;;
  403.   (+ (lsh (- (car b) (car a)) 16)
  404.      (- (nth 1 b) (nth 1 a)) ))
  405.  
  406. (add-hook 'skk-before-kill-emacs-hook 'skk-attr-save)
  407.  
  408. (provide 'skk-attr)
  409. ;;; skk-attr.el ends here
  410.